;; supercollider/ugen-math.scm - (c) rohan drape, 2003-2005

;; Get the rate of the input value `o'.  If `o' is not a UGen, or
;; Output Proxy, or Lisp Number, or Control, or list of such, an error
;; is raised.

(define (ugen-math-input-rate o)
  (cond ((or (number? o) (constant? o))
	 0)
	((control? o)
	 (control-rate o))
	((ugen? o)
	 (ugen-rate o))
	((output-proxy? o)
	 (ugen-rate (output-proxy-ugen o)))
	((list? o)
	 (apply max (map ugen-math-input-rate o)))
	(else 
	 (error "Illegal input to Math UGen" o))))

;; The unary generic math operator.

(define (ugen-math-generic-unary sc3-ar sc3-kr sc3-ir sc3-dr 
				 lisp 
				 input)
  (if (number? input)
      (lisp input)
      (let* ((rate (ugen-math-input-rate input))
	     (op (case rate
		   ((0) sc3-ir)
		   ((1) sc3-kr)
		   ((2) sc3-ar)
		   ((3) sc3-dr)
		   (else (error "ugen-math-generic-nary: illegal input rate" 
				rate)))))
	(op input))))

;; The recursive nary generic math operator.  This has to be at global
;; scope because it is named in an s-expression passed to 'eval'.

(define (ugen-math-generic-nary sc3-ar sc3-kr sc3-ir sc3-dr 
				lisp 
				left right . rest)
  
  ;; Evaluates to the operation to combine `left' and `right' and
  ;; operating at the highest rate of the pair, or using the `lisp'
  ;; operator if both are primitive lisp objects.

  (define (generic-binary left right)
    (if (and (number? left) (number? right))
	(lisp left right)
	(let* ((max-rate (max (ugen-math-input-rate left) 
			      (ugen-math-input-rate right)))
	       (op (case max-rate
		     ((0) sc3-ir)
		     ((1) sc3-kr)
		     ((2) sc3-ar)	
		     ((3) sc3-dr)
		     (else (error "generic-binary: illegal input rate" 
				  max-rate)))))
	  (op left right))))
  
  (if (null? rest)
      (generic-binary left right)
      (generic-binary left (apply ugen-math-generic-nary 
				  sc3-ar sc3-kr sc3-ir sc3-dr 
				  lisp 
				  right rest))))

;; Generate s-expression definitions for the generic math UGen
;; procedures.

(define (ugen-math-compile)
  
  ;; The table connecting SC3 UGen names with equivalent lisp
  ;; procedures.
  
  (define unary-table
    '((Neg -)
      (Not not)
      (IsNil zero?)
      (NotNil error)
      (BitNot bitwise-not)
      (Abs abs)
      (AsFloat identity)
      (AsInt roundE)
      (Ceil ceiling)
      (Floor floor)
      (Frac error)
      (Sign error)
      (Squared square)
      (Cubed cube)
      (Sqrt sqrt)
      (Exp exp)
      (Recip reciprocal)
      (MIDICPS midi-note->frequency)
      (CPSMIDI frequency->midi-note)
      (MIDIRatio midi-note->ratio)
      (RatioMIDI ratio->midi-note)
      (DbAmp db-to-rms)
      (AmpDb rms-to-db)
      (OctCPS error)
      (CPSOct error)
      (Log log)
      (Log2 error)
      (Log10 log10)
      (Sin sin)
      (Cos cos)
      (Tan tan)
      (ArcSin asin)
      (ArcCos acos)
      (ArcTan atan)
      (SinH error)
      (CosH error)
      (TanH error)
      (Rand random)
      (Rand2 error)
      (LinRand error)
      (BiLinRand error)
      (Sum3Rand error)
      (Distort error)
      (SoftClip error)
      (Coin random-boolean)
      (DigitValue error)
      (Silence error)
      (Thru error)
      (RectWindow error)
      (HanWindow error)
      (WelchWindow error)
      (TriWindow error)
      (Ramp error)
      (SCurve error)))

  ;; The correspondance table connecting SC3 UGen names with
  ;; equivalent lisp procedures.
  
  (define binary-table
    '((Add +)
      (Sub -)
      (Mul *)
      (IDiv /)
      (FDiv /)
      (Mod modulo)
      (EQ =)
      (NE error)
      (LT <)
      (GT >)
      (LE <=)
      (GE >=)
      (Min min)
      (Max max)
      (BitAnd bitwise-and)
      (BitOr bitwise-ior)
      (BitXor bitwise-xor)
      (LCM lcm)
      (GCD gcd)
      (Round round)
      (Trunc error)
      (Atan2 error)
      (Hypot error)
      (Hypotx error)
      (Pow expt)
      (ShiftLeft arithmetic-shift)
      (ShiftRight error)
      (UnsignedShift error)
      (Fill  error)
      (Ring1 error)
      (Ring2 error)
      (Ring3 error)
      (Ring4 error)
      (DifSqr error)
      (SumSqr error)
      (SqrSum error)
      (SqrDif error)
      (AbsDif error)
      (Thresh error)
      (AMClip error)
      (ScaleNeg error)
      (Clip2 error)
      (Excess error)
      (Fold2 error)
      (Wrap2 error)
      (FirstArg error)
      (RandRange error)
      (ExpRandRange error)))

  (let ((u-e 
	 (map (lambda (name+lisp)
		(let* ((name (symbol->string (car name+lisp)))
		       (lisp (cadr name+lisp))
		       (bind-to (string->symbol name)))
		  (list 'define bind-to
			(list 'lambda '(input)
			      (list 'ugen-math-generic-unary 
				    (string->symbol (format "_~a.ar" name))
				    (string->symbol (format "_~a.kr" name))
				    (string->symbol (format "_~a.ir" name))
				    (string->symbol (format "_~a.dr" name))
				    lisp
				    'input)))))
	      unary-table))
	
	;; This looses some precision since it cannot use formal
	;; arguments with a final 'rest' list, mzscheme complains of
	;; invalid use of dot when quoted.
	
	(b-e 
	 (map (lambda (name+lisp)
		(let* ((name (symbol->string (car name+lisp)))
		       (lisp (cadr name+lisp))
		       (bind-to (string->symbol name)))
		  (list 'define bind-to
			(list 'lambda 'args
			      (list 'apply 
				    'ugen-math-generic-nary 
				    (string->symbol (format "_~a.ar" name))
				    (string->symbol (format "_~a.kr" name))
				    (string->symbol (format "_~a.ir" name))
				    (string->symbol (format "_~a.dr" name))
				    lisp
				    'args)))))
	      binary-table)))
    
    (append u-e b-e)))

